home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 14 / hacker14.iso / programacao / visual / perl.exe / {app} / Library / YAPE / Regex.pm
Encoding:
Perl POD Document  |  2001-05-03  |  25.2 KB  |  874 lines
  1. package YAPE::Regex;
  2.  
  3. use YAPE::Regex::Element;
  4. use Text::Balanced 'extract_codeblock';
  5. use Carp;
  6. use strict;
  7. use vars '$VERSION';
  8.  
  9.  
  10. $VERSION = '3.00';
  11.  
  12.  
  13. my $valid_POSIX = qr{
  14.   alpha | alnum | ascii | cntrl | digit | graph |
  15.   lower | print | punct | space | upper | word | xdigit
  16. }x;
  17.  
  18.  
  19. my $ok_cc_REx = qr{
  20.   \\([0-3][0-7]{2}) |                       # octal escapes
  21.   \\x([a-fA-F0-9]{2}|\{[a-fA-F0-9]+\}) |    # hex escapes
  22.   \\c(.) |                                  # control characters
  23.   \\([nrftbae]) |                           # known \X sequences
  24.   \\N\{([^\}]+)\} |                         # named characters
  25.   (\\[wWdDsS]) |                            # regex macros
  26.   \\[Pp]([A-Za-z]|\{[a-zA-Z]+\}) |          # utf8 macros
  27.   \[:\^?([a-zA-Z]+):\]  |                   # POSIX macros
  28.   \\?(.)                                    # anything else
  29. }xs;
  30.  
  31.  
  32. my %pat = (
  33.   Pcomment => qr{ \( \? \# ( [^)]* ) \) }x,
  34.   Xcomment => qr{ \# [^\S\n]* ( .* \n ) }x,
  35.   Pflags => qr{ \( \? ([isxm]*)-?([ismx]*) \) }x,
  36.  
  37.   Pahead => qr{ \( \? ( [=!] ) }x,
  38.   Pbehind => qr{ \( \? < ( [=!] ) }x,
  39.   Pcond => qr{ \( \? (?: \( (\d+) \) | (?= \( \? (?: <? [=!] | \?? \{ ) ) ) }x,
  40.   Pcut => qr{ \( \? > }x,
  41.   Pgroup => qr{ \( \? ([isxm]*)-?([ismx]*) : }x,
  42.   Pcapture => qr{ \( (?! \? ) }x,
  43.   Pcode => qr{ \( \? (?= \{ ) }x,
  44.   Plater => qr{ \( \? \? (?= \{ ) }x,
  45.   Pclose => qr{ \) }x,
  46.  
  47.   quant => qr{ ( (?: [+*?] | \{ \d+ ,? \d* \} ) ) }x,
  48.   ngreed => qr{ ( \? ) }x,
  49.  
  50.   anchor => qr{ ( \\ [ABbGZz] | [\^\$] ) }x,
  51.   macro => qr{ \\ ( [dDwWsS] ) }x,
  52.   oct => qr{ \\ ( [0-3] [0-7] [0-7] ) }x,
  53.   hex => qr{ \\ x ( [a-fA-F0-9]{2} ) }x,
  54.   utf8hex => qr{ \\ x \{ ( [a-fA-F0-9]+ ) \} }x,
  55.   backref => qr{ \\ ( [1-9] \d* ) }x,
  56.   ctrl => qr{ \\ c ( . ) }x,
  57.   named => qr{ \\ N \{ ( [^\}]+ ) \} }x,
  58.   Cchar => qr{ \\ C }x,
  59.   slash => qr{ \\ ( . ) }x,
  60.   any => qr{ \. }x,
  61.   class => qr{ \\ ([Pp]) ( [A-Za-z] | \{ [a-zA-Z]+ \} ) | \[ ( \^? ) ( \]? [^][\\]* (?: (?: \[:\w+:\] | \[ (?!:) | \\. ) [^][\\]* )* ) \] }x,
  62.   nws => qr{ ( (?: [^\s^\$|\\+*?()\[.]+ | \{ (?! \d+ ,? \d* \} ) )+ ) }x,
  63.   reg => qr{ ( (?: [^^\$|\\+*?()\[.\{] | \{ (?! \d+ ,? \d* \} ) )+ ) }x,
  64.  
  65.   alt => qr{ \| }x,
  66. );
  67.  
  68.  
  69. sub import {
  70.   shift;
  71.   my @obj = qw(
  72.     anchor macro oct hex utf8hex backref ctrl named Cchar slash
  73.     any class text alt comment whitespace flags lookahead lookbehind
  74.     conditional group capture code later close cut
  75.   );
  76.   no strict 'refs';
  77.   for my $class ('YAPE::Regex', @_) {
  78.     (my $file = $class . ".pm") =~ s!::!/!g;
  79.     require $file and $class->import if not $INC{$file};
  80.     if ($class ne 'YAPE::Regex') {
  81.       push @{"${class}::ISA"}, 'YAPE::Regex';
  82.       push @{"${class}::${_}::ISA"},
  83.         "YAPE::Regex::$_", "${class}::Element" for @obj;
  84.     }
  85.     push @{"${class}::${_}::ISA"}, 'YAPE::Regex::Element' for @obj;
  86.   }
  87. } 
  88.  
  89.  
  90. sub new {
  91.   my ($class, $regex) = @_;
  92.  
  93.   croak "no regex given to $class->new"
  94.     if not defined $regex or length($regex) == 0;
  95.  
  96.   eval { local $^W; $regex = qr/$regex/ } if ref($regex) ne 'Regexp';
  97.  
  98.   $regex = "(?-imsx:$regex)" if $@;
  99.  
  100.   my $self = bless {
  101.     TREE => [],
  102.     TREE_STACK => [],
  103.     CAPTURE => [],
  104.     CONTENT => "$regex",
  105.     DEPTH => 0,
  106.   }, $class;
  107.   $self->{CURRENT} = $self->{TREE};
  108.  
  109.   return $self;
  110. }
  111.  
  112.  
  113. sub state { $_[0]{STATE} }
  114. sub error { $_[0]{ERROR} }
  115. sub depth { $_[0]{DEPTH} }
  116. sub chunk { substr $_[0]{CONTENT}, 0, $_[1] || 30 }
  117. sub done { $_[0]{STATE} eq 'done' }
  118. sub root { $_[0]{TREE}[0] }
  119. sub top { $_[0]{TREE}[0] }
  120. sub parse { 1 while $_[0]->next }
  121. sub display { $_[0]->parse; $_[0]{TREE}[0]->fullstring if $_[0]->done;  }
  122.  
  123.  
  124. sub next {
  125.   my $self = shift;
  126.   $self->{STATE} = 'done', return unless length $self->{CONTENT};
  127.  
  128.   if (
  129.     @{$self->{TREE_STACK}} and
  130.     $self->{TREE_STACK}[-1]{MODE}{x} and
  131.     $self->{CONTENT} =~ s/^(\s+)//
  132.   ) {
  133.     my $node = (ref($self) . "::whitespace")->new($1);
  134.     push @{ $self->{CURRENT} }, $node;
  135.     return $node;
  136.   }
  137.  
  138.   if ($self->{CONTENT} =~ s/^$pat{Pcomment}//) {
  139.     my $node = (ref($self) . "::comment")->new($1,0);
  140.     push @{ $self->{CURRENT} }, $node;
  141.     $self->{STATE} = 'comment';
  142.     return $node;
  143.   }
  144.  
  145.   if (
  146.     @{ $self->{TREE_STACK} } and
  147.     $self->{TREE_STACK}[-1]{MODE}{x} and
  148.     $self->{CONTENT} =~ s/^$pat{Xcomment}//
  149.   ) {
  150.     my $node = (ref($self) . "::comment")->new($1,1);
  151.     push @{ $self->{CURRENT} }, $node;
  152.     $self->{STATE} = 'comment';
  153.     return $node;
  154.   }
  155.  
  156.   if ($self->{CONTENT} =~ s/^$pat{anchor}//) {
  157.     my $match = $1;
  158.     my ($quant,$ngreed) = $self->_get_quant;
  159.     return if $quant eq -1;
  160.     my $node = (ref($self) . "::anchor")->new($match,$quant,$ngreed);
  161.     push @{ $self->{CURRENT} }, $node;
  162.     $self->{STATE} = 'anchor';
  163.     return $node;
  164.   }
  165.  
  166.   if ($self->{CONTENT} =~ s/^$pat{macro}//) {
  167.     my $match = $1;
  168.     my ($quant,$ngreed) = $self->_get_quant;
  169.     return if $quant eq -1;
  170.     my $node = (ref($self) . "::macro")->new($match,$quant,$ngreed);
  171.     push @{ $self->{CURRENT} }, $node;
  172.     $self->{STATE} = 'macro';
  173.     return $node;
  174.   }
  175.  
  176.   if ($self->{CONTENT} =~ s/^$pat{oct}//) {
  177.     my $match = $1;
  178.     my ($quant,$ngreed) = $self->_get_quant;
  179.     return if $quant eq -1;
  180.     my $node = (ref($self) . "::oct")->new($match,$quant,$ngreed);
  181.     push @{ $self->{CURRENT} }, $node;
  182.     $self->{STATE} = 'oct';
  183.     return $node;
  184.   }
  185.  
  186.   if ($self->{CONTENT} =~ s/^$pat{hex}//) {
  187.     my $match = $1;
  188.     my ($quant,$ngreed) = $self->_get_quant;
  189.     my $node = (ref($self) . "::hex")->new($match,$quant,$ngreed);
  190.     push @{ $self->{CURRENT} }, $node;
  191.     $self->{STATE} = 'hex';
  192.     return $node;
  193.   }
  194.  
  195.   if ($self->{CONTENT} =~ s/^$pat{utf8hex}//) {
  196.     my $match = $1;
  197.     my ($quant,$ngreed) = $self->_get_quant;
  198.     my $node = (ref($self) . "::utf8hex")->new($match,$quant,$ngreed);
  199.     push @{ $self->{CURRENT} }, $node;
  200.     $self->{STATE} = 'utf8hex';
  201.     return $node;
  202.   }
  203.  
  204.   if ($self->{CONTENT} =~ s/^$pat{backref}//) {
  205.     my $match = $1;
  206.     my ($quant,$ngreed) = $self->_get_quant;
  207.     return if $quant eq -1;
  208.     my $node = (ref($self) . "::backref")->new($match,$quant,$ngreed);
  209.  
  210.   # this code is special for YAPE::Regex::Reverse
  211.   if ($self->isa('YAPE::Regex::Reverse')) {
  212.     if ($quant eq '*' or $quant eq '+') {
  213.       $node = (ref($self) . "::group")->new;
  214.       $node->{NGREED} = '?' if $quant eq '*';
  215.       $node->{CONTENT} = [
  216.         (ref($self) . "::backref")->new($match,'*'),
  217.         (ref($self) . "::backref")->new($match),
  218.       ];
  219.     }
  220.     elsif ($quant and $quant ne '?') {
  221.       my ($l,$u) = $quant =~ /(\d+),(\d*)/;
  222.       $node = (ref($self) . "::group")->new;
  223.       $node->{NGREED} = '?' if not $l;
  224.       $l-- if $l; $u-- if $u;
  225.       $node->{CONTENT} = [
  226.         (ref($self) . "::backref")->new($match,"{$l,$u}"),
  227.         (ref($self) . "::backref")->new($match),
  228.       ];
  229.     }
  230.   }
  231.     push @{ $self->{CURRENT} }, $node;
  232.     $self->{STATE} = 'backref';
  233.     return $node;
  234.   }
  235.  
  236.   if ($self->{CONTENT} =~ s/^$pat{ctrl}//) {
  237.     my $match = $1;
  238.     my ($quant,$ngreed) = $self->_get_quant;
  239.     return if $quant eq -1;
  240.     my $node = (ref($self) . "::ctrl")->new($match,$quant,$ngreed);
  241.     push @{ $self->{CURRENT} }, $node;
  242.     $self->{STATE} = 'ctrl';
  243.     return $node;
  244.   }
  245.  
  246.   if ($self->{CONTENT} =~ s/^$pat{named}//) {
  247.     my $match = $1;
  248.     my ($quant,$ngreed) = $self->_get_quant;
  249.     return if $quant eq -1;
  250.     my $node = (ref($self) . "::named")->new($match,$quant,$ngreed);
  251.     push @{ $self->{CURRENT} }, $node;
  252.     $self->{STATE} = 'named';
  253.     return $node;
  254.   }
  255.  
  256.   if ($self->{CONTENT} =~ s/^$pat{Cchar}//) {
  257.     my ($quant,$ngreed) = $self->_get_quant;
  258.     return if $quant eq -1;
  259.     my $node = (ref($self) . "::Cchar")->new($quant,$ngreed);
  260.     push @{ $self->{CURRENT} }, $node;
  261.     $self->{STATE} = 'Cchar';
  262.     return $node;
  263.   }
  264.  
  265.   if ($self->{CONTENT} =~ s/^$pat{class}//) {
  266.     my ($neg,$match) = defined($1) ? ($1,$2) : ($3,$4);
  267.     $match =~ tr/{}//d if defined $1;
  268.         
  269.     my ($quant,$ngreed) = $self->_get_quant;
  270.     return if $quant eq -1;
  271.     return unless $self->_ok_class($match);
  272.     my $node = (ref($self) . "::class")->new($match,$neg,$quant,$ngreed);
  273.     push @{ $self->{CURRENT} }, $node;
  274.     $self->{STATE} = 'class';
  275.     return $node;
  276.   }
  277.  
  278.   if ($self->{CONTENT} =~ s/^$pat{slash}//) {
  279.     my $match = $1;
  280.     my ($quant,$ngreed) = $self->_get_quant;
  281.     return if $quant eq -1;
  282.     my $node = (ref($self) . "::slash")->new($match,$quant,$ngreed);
  283.     push @{ $self->{CURRENT} }, $node;
  284.     $self->{STATE} = 'slash';
  285.     return $node;
  286.   }
  287.  
  288.   if ($self->{CONTENT} =~ s/^$pat{any}//) {
  289.     my ($quant,$ngreed) = $self->_get_quant;
  290.     return if $quant eq -1;
  291.     my $node = (ref($self) . "::any")->new($quant,$ngreed);
  292.     push @{ $self->{CURRENT} }, $node;
  293.     $self->{STATE} = 'any';
  294.     return $node;
  295.   }
  296.  
  297.   if (
  298.     @{ $self->{TREE_STACK} } and
  299.     $self->{TREE_STACK}[-1]{MODE}{x} and
  300.     $self->{CONTENT} =~ s/^$pat{nws}//
  301.   ) {
  302.     my $match = $1;
  303.     my ($quant,$ngreed) = $self->_get_quant;
  304.     my $node = (ref($self) . "::text")->new($match,$quant,$ngreed);
  305.     push @{ $self->{CURRENT} }, $node;
  306.     $self->{STATE} = 'text';
  307.     return $node;
  308.   }
  309.  
  310.   if ($self->{CONTENT} =~ s/^$pat{reg}//) {
  311.     my $match = $1;
  312.     my $node;
  313.     if (length($match) > 1 and $self->{CONTENT} =~ /^$pat{quant}/) {
  314.       $self->{CONTENT} = chop($match) . $self->{CONTENT};
  315.       $node = (ref($self) . "::text")->new($match,"","");
  316.     }
  317.     else {
  318.       my ($quant,$ngreed) = $self->_get_quant;
  319.       return if $quant eq -1;
  320.       $node = (ref($self) . "::text")->new($match,$quant,$ngreed);
  321.     }      
  322.     push @{ $self->{CURRENT} }, $node;
  323.     $self->{STATE} = 'text';
  324.     return $node;
  325.   }
  326.  
  327.   if ($self->{CONTENT} =~ s/^$pat{alt}//) {{
  328.     if (
  329.       @{ $self->{TREE_STACK} } and
  330.       $self->{TREE_STACK}[-1]->type eq 'cond' and
  331.       $self->{TREE_STACK}[-1]{OPTS} == 2
  332.     ) {
  333.       $self->{CONTENT} = '|' . $self->{CONTENT};
  334.       last;
  335.     }
  336.     my $node = (ref($self) . "::alt")->new;
  337.     if (
  338.       @{ $self->{TREE_STACK} } and
  339.       $self->{TREE_STACK}[-1]->type eq 'cond'
  340.     ) {
  341.       $self->{TREE_STACK}[-1]{OPTS}++;
  342.       $self->{CURRENT} = $self->{TREE_STACK}[-1]{FALSE};
  343.     }
  344.     else {
  345.       push @{ $self->{CURRENT} }, $node;
  346.     }
  347.     $self->{STATE} = 'alt';
  348.     return $node;
  349.   }}
  350.  
  351.   if ($self->{CONTENT} =~ s/^$pat{Pflags}//) {
  352.     my ($add,$sub) = ($1,$2);
  353.     my $mode = $self->{TREE_STACK}[-1]{MODE};
  354.     @{$mode}{split //, $add} = (1) x length($add);
  355.     delete @{$mode}{split //, $sub};
  356.     my $node = (ref($self) . "::flags")->new($add,$sub);
  357.     push @{ $self->{CURRENT} }, $node;
  358.     $self->{STATE} = 'flags';
  359.     return $node;
  360.   }
  361.  
  362.   if ($self->{CONTENT} =~ s/^$pat{Pcond}//) {
  363.     if (defined $1) {
  364.       my $node = (ref($self) . "::conditional")->new($1);
  365.       $node->{MODE} = { %{ $self->{TREE_STACK}[-1]{MODE} } } if
  366.           @{ $self->{TREE_STACK} };
  367.       push @{ $self->{TREE_STACK} }, $node;
  368.       push @{ $self->{CURRENT} }, $node;
  369.       $self->{CURRENT} = $node->{TRUE};
  370.       $self->{DEPTH}++;
  371.       $self->{STATE} = "cond($1)";
  372.       return $node;
  373.     }
  374.     else {
  375.       my $node = (ref($self) . "::conditional")->new;
  376.       $node->{MODE} = { %{ $self->{TREE_STACK}[-1]{MODE} } } if
  377.           @{ $self->{TREE_STACK} };
  378.       push @{ $self->{TREE_STACK} }, $node;
  379.       push @{ $self->{CURRENT} }, $node;
  380.       $self->{CURRENT} = $node->{CONTENT};
  381.       $self->{DEPTH}++;
  382.       $self->{STATE} = "cond(assert)";
  383.       return $node;
  384.     }
  385.   }
  386.  
  387.   if ($self->{CONTENT} =~ s/^$pat{Pcut}//) {
  388.     my ($quant,$ngreed) = $self->_get_quant;
  389.     return if $quant eq -1;
  390.     my $node = (ref($self) . "::cut")->new([],$quant,$ngreed);
  391.     $node->{MODE} = { %{ $self->{TREE_STACK}[-1]{MODE} } };
  392.     push @{ $self->{TREE_STACK} }, $node;
  393.     push @{ $self->{CURRENT} }, $node;
  394.     $self->{CURRENT} = $node->{CONTENT};
  395.     $self->{DEPTH}++;
  396.     $self->{STATE} = 'cut';
  397.     return $node;
  398.   }
  399.  
  400.   if ($self->{CONTENT} =~ s/^$pat{Pahead}//) {
  401.     my $node = (ref($self) . "::lookahead")->new($1 eq '=' ? 1 : 0);
  402.     $node->{MODE} = { %{ $self->{TREE_STACK}[-1]{MODE} } };
  403.     push @{ $self->{TREE_STACK} }, $node;
  404.     push @{ $self->{CURRENT} }, $node;
  405.     $self->{CURRENT} = $node->{CONTENT};
  406.     $self->{DEPTH}++;
  407.     $self->{STATE} = 'lookahead(' . ('neg','pos')[$1 eq '='] . ')';
  408.     return $node;
  409.   }
  410.  
  411.   if ($self->{CONTENT} =~ s/^$pat{Pbehind}//) {
  412.     my $node = (ref($self) . "::lookbehind")->new($1 eq '=' ? 1 : 0);
  413.     $node->{MODE} = { %{ $self->{TREE_STACK}[-1]{MODE} } };
  414.     push @{ $self->{TREE_STACK} }, $node;
  415.     push @{ $self->{CURRENT} }, $node;
  416.     $self->{CURRENT} = $node->{CONTENT};
  417.     $self->{DEPTH}++;
  418.     $self->{STATE} = 'lookbehind(' . ('neg','pos')[$1 eq '='] . ')';
  419.     return $node;
  420.   }
  421.  
  422.   if ($self->{CONTENT} =~ s/^$pat{Pgroup}//) {
  423.     my ($add,$sub) = ($1,$2);
  424.     my $node = (ref($self) . "::group")->new($add || "",$sub || "");
  425.     $node->{MODE} = { %{ $self->{TREE_STACK}[-1]{MODE} } } if
  426.       @{ $self->{TREE_STACK} };
  427.     @{$node->{MODE}}{split //, $add} = (1) x length($add);
  428.     delete @{$node->{MODE}}{split //, $sub};
  429.     push @{ $self->{TREE_STACK} }, $node;
  430.     push @{ $self->{CURRENT} }, $node;
  431.     $self->{CURRENT} = $node->{CONTENT};
  432.     $self->{DEPTH}++;
  433.     $self->{STATE} = 'group';
  434.     return $node;
  435.   }
  436.  
  437.   if ($self->{CONTENT} =~ s/^$pat{Pcapture}//) {
  438.     my $node = (ref($self) . "::capture")->new;
  439.     $node->{MODE} = { %{ $self->{TREE_STACK}[-1]{MODE} } } if
  440.       @{ $self->{TREE_STACK} };
  441.     push @{ $self->{TREE_STACK} }, $node;
  442.     push @{ $self->{CURRENT} }, $node;
  443.     push @{ $self->{CAPTURE} }, $node;
  444.     $self->{CURRENT} = $node->{CONTENT};
  445.     $self->{DEPTH}++;
  446.     $self->{STATE} = 'capture(' . @{ $self->{CAPTURE} } . ')';
  447.     return $node;
  448.   }
  449.  
  450.   if ($self->{CONTENT} =~ s/^$pat{Pcode}//) {
  451.     my ($code,$left) = extract_codeblock($self->{CONTENT}) or do {
  452.       $self->{ERROR} = 'bad code in (?{ ... }) assertion';
  453.       $self->{STATE} = 'error';
  454.       return;
  455.     };
  456.     
  457.     $self->{CONTENT} = $left;
  458.     my $node = (ref($self) . "::code")->new($code);
  459.     push @{ $self->{TREE_STACK} }, $node;
  460.     push @{ $self->{CURRENT} }, $node;
  461.     $self->{DEPTH}++;
  462.     $self->{STATE} = 'code';
  463.     return $node;
  464.   }
  465.   
  466.   if ($self->{CONTENT} =~ s/^$pat{Plater}//) {
  467.     my ($code,$left) = extract_codeblock($self->{CONTENT}) or do {
  468.       $self->{ERROR} = 'bad code in (??{ ... }) assertion';
  469.       $self->{STATE} = 'error';
  470.       return;
  471.     };
  472.     
  473.     $self->{CONTENT} = $left;
  474.     my $node = (ref($self) . "::later")->new($code);
  475.     push @{ $self->{TREE_STACK} }, $node;
  476.     push @{ $self->{CURRENT} }, $node;
  477.     $self->{DEPTH}++;
  478.     $self->{STATE} = 'later';
  479.     return $node;
  480.   }
  481.   
  482.   if ($self->{DEPTH}-- and $self->{CONTENT} =~ s/^$pat{Pclose}//) {
  483.     my ($quant,$ngreed) = $self->_get_quant;
  484.     return if $quant eq -1;
  485.     my $node = (ref($self) . "::close")->new;
  486.     
  487.     $self->{CURRENT} = pop @{ $self->{TREE_STACK} };
  488.     $self->{CURRENT}{QUANT} = $quant;
  489.     $self->{CURRENT}{NGREED} = $ngreed;
  490.  
  491.   # this code is special to YAPE::Regex::Reverse
  492.   if ($self->isa('YAPE::Regex::Reverse')) {
  493.     if ($quant eq '*' or $quant eq '+') {
  494.       my $old = $self->{CURRENT}{CONTENT};
  495.       $self->{CURRENT}{CONTENT} = [
  496.         (ref($self) . "::group")->new,
  497.         (ref($self) . "::capture")->new,
  498.       ];
  499.       $self->{CURRENT}{NGREED} = '?' if $quant eq '*';
  500.       $self->{CURRENT}{CONTENT}[0]{CONTENT} = $old;
  501.       $self->{CURRENT}{CONTENT}[0]{QUANT} = '*';
  502.       $self->{CURRENT}{CONTENT}[1]{CONTENT} = $old;
  503.       $self->{CAPTURE}[-1] = $self->{CURRENT}{CONTENT}[1];
  504.       bless $self->{CURRENT}, (ref($self) . '::group');
  505.     }
  506.     elsif ($quant and $quant ne '?') {
  507.       my ($l,$u) = $quant =~ /(\d+),(\d*)/;
  508.       my $old = $self->{CURRENT}{CONTENT};
  509.       $self->{CURRENT}{CONTENT} = [
  510.         (ref($self) . "::group")->new,
  511.         (ref($self) . "::capture")->new,
  512.       ];
  513.       $self->{CURRENT}{NGREED} = '?' if not $l;
  514.       $l-- if $l; $u-- if $u;
  515.       $self->{CURRENT}{CONTENT}[0]{CONTENT} = $old;
  516.       $self->{CURRENT}{CONTENT}[0]{QUANT} = "{$l,$u}";
  517.       $self->{CURRENT}{CONTENT}[1]{CONTENT} = $old;
  518.       $self->{CAPTURE}[-1] = $self->{CURRENT}{CONTENT}[1];
  519.       bless $self->{CURRENT}, (ref($self) . '::group');
  520.     }
  521.   }
  522.  
  523.     if (
  524.       @{ $self->{TREE_STACK} } and
  525.       $self->{TREE_STACK}[-1]->type eq 'cond' and
  526.       $self->{TREE_STACK}[-1]{OPTS} == 1
  527.     ) {
  528.       $self->{CURRENT} = $self->{TREE_STACK}[-1]{TRUE};
  529.     }
  530.     else {
  531.       $self->{CURRENT} = $self->{TREE_STACK}[-1];
  532.       $self->{CURRENT} = $self->{CURRENT}{CONTENT};
  533.     }
  534.     
  535.     $self->{STATE} = 'close';
  536.     return $node;
  537.   }
  538.  
  539.   my $token = $self->chunk(1);
  540.   $self->{ERROR} = "unexpected token '$token' during '$self->{STATE}'";
  541.   $self->{STATE} = 'error';
  542.  
  543.   return;
  544. }
  545.  
  546.  
  547. sub extract {
  548.   my $self = shift;
  549.   $self->parse;
  550.   
  551.   my @nodes = @{ $self->{CAPTURE} };
  552.   
  553.   return sub { shift @nodes };
  554. }
  555.  
  556.  
  557. sub _get_quant {
  558.   my $self = shift;
  559.   my ($quant,$ngreed) = ("","");
  560.  
  561.   if (
  562.     $self->{CONTENT} =~ s/^($pat{Pcomment})?$pat{quant}// or
  563.     (@{ $self->{TREE_STACK} } and $self->{TREE_STACK}[-1]{MODE}{x} and
  564.       $self->{CONTENT} =~ s/^($pat{Xcomment}?\s*)?$pat{quant}//)
  565.   ) {
  566.     $quant = $+;
  567.     {
  568.       if ($quant =~ /^\{(\d+),(\d+)\}/ and $1 > $2) {
  569.         $self->{ERROR} = "upper bound lower than lower bound ($quant)";
  570.         $self->{STATE} = 'error';
  571.         return -1;
  572.       }
  573.     }
  574.     $self->{CONTENT} = $1 . $self->{CONTENT} if $1;
  575.   }
  576.  
  577.   my ($ws) = $1 if
  578.     @{ $self->{TREE_STACK} } and
  579.     $self->{TREE_STACK}[-1]{MODE}{x} and
  580.     $self->{CONTENT} =~ s/^(\s+)//;
  581.  
  582.   if (
  583.     (@{ $self->{TREE_STACK} } and $self->{TREE_STACK}[-1]{MODE}{x} and
  584.       $self->{CONTENT} =~ s/^($pat{Xcomment}?\s*)?$pat{ngreed}//) or
  585.       $self->{CONTENT} =~ s/^($pat{Pcomment})?$pat{ngreed}//
  586.   ) {
  587.     $ngreed = $+;
  588.     $self->{CONTENT} = $1 . $self->{CONTENT} if $1;
  589.   }
  590.  
  591.   $self->{CONTENT} = $ws . $self->{CONTENT} if $ws;
  592.  
  593.   return ($quant,$ngreed);
  594. }
  595.  
  596.  
  597. sub _ok_class {
  598.   my ($self,$class) = @_;
  599.  
  600.   while ($class =~ s/^($ok_cc_REx)//) {
  601.     my $c1 = $1;
  602.  
  603.     my $a =
  604.       defined($2) ? oct($2) :
  605.       defined($3) ? hex(($3 =~ /(\w+)/)[0]) :
  606.       defined($4) ? ord($4) - 64 :
  607.       defined($5) ? ord(eval qq{"\\$5"}) :
  608.       defined($6) ? ord(eval qq{use charnames ':full'; "\\N{$6}"}) :
  609.       defined($10) ? ord($10) :
  610.                     -1;
  611.  
  612.     my ($utf8,$posix) = ($8,$9);
  613.     
  614.     $utf8 =~ tr/{}//d if defined $utf8;
  615.  
  616.     if (defined($posix) and $posix !~ $valid_POSIX) {
  617.       $self->{ERROR} = "unknown POSIX class $c1";
  618.       $self->{STATE} = 'error';
  619.       return;
  620.     }
  621.  
  622.     if ($class =~ s/^-($ok_cc_REx)//) {
  623.       my $c2 = $1;
  624.       my $b =
  625.         defined($2) ? oct($2) :
  626.         defined($3) ? hex(($3 =~ /(\w+)/)[0]) :
  627.         defined($4) ? ord($4) - 64 :
  628.         defined($5) ? ord(eval qq{"\\$5"}) :
  629.         defined($6) ? ord(eval qq{use charnames ':full'; "\\N{$6}"}) :
  630.         defined($10) ? ord($10) :
  631.                       -1;
  632.  
  633.       my ($utf8,$posix) = ($8,$9);
  634.       
  635.       $utf8 =~ tr/{}//d if defined $utf8;
  636.   
  637.       if (defined($posix) and $posix !~ $valid_POSIX) {
  638.         $self->{ERROR} = "unknown POSIX class $c2";
  639.         $self->{STATE} = 'error';
  640.         return;
  641.       }
  642.   
  643.       if ($a == -1 or $b == -1) {
  644.         carp qq{false [] range "$c1-$c2"} if $^W;
  645.       }
  646.       elsif ($a > $b) {
  647.         $self->{ERROR} = "invalid [] range $c1-$c2";
  648.         $self->{STATE} = 'error';
  649.         return;
  650.       }
  651.     }
  652.   }
  653.  
  654.   return 1;
  655. }
  656.  
  657.  
  658. 1;
  659.  
  660. __END__
  661.  
  662. =head1 NAME
  663.  
  664. YAPE::Regex - Yet Another Parser/Extractor for Regular Expressions
  665.  
  666. =head1 SYNOPSIS
  667.  
  668.   use YAPE::Regex;
  669.   use strict;
  670.   
  671.   my $regex = qr/reg(ular\s+)?exp?(ression)?/i;
  672.   my $parser = YAPE::Regex->new($regex);
  673.   
  674.   # here is the tokenizing part
  675.   while (my $chunk = $parser->next) {
  676.     # ...
  677.   }
  678.  
  679. =head1 C<YAPE> MODULES
  680.  
  681. The C<YAPE> hierarchy of modules is an attempt at a unified means of parsing
  682. and extracting content.  It attempts to maintain a generic interface, to
  683. promote simplicity and reusability.  The API is powerful, yet simple.  The
  684. modules do tokenization (which can be intercepted) and build trees, so that
  685. extraction of specific nodes is doable.
  686.  
  687. =head1 DESCRIPTION
  688.  
  689. This module is yet another (?) parser and tree-builder for Perl regular
  690. expressions.  It builds a tree out of a regex, but at the moment, the extent of
  691. the extraction tool for the tree is quite limited (see L<Extracting Sections>).
  692. However, the tree can be useful to extension modules.
  693.  
  694. =head1 USAGE
  695.  
  696. In addition to the base class, C<YAPE::Regex>, there is the auxiliary class
  697. C<YAPE::Regex::Element> (common to all C<YAPE> base classes) that holds the
  698. individual nodes' classes.  There is documentation for the node classes in
  699. that module's documentation.
  700.  
  701. =head2 Methods for C<YAPE::Regex>
  702.  
  703. =over 4
  704.  
  705. =item * C<use YAPE::Regex;>
  706.  
  707. =item * C<use YAPE::Regex qw( MyExt::Mod );>
  708.  
  709. If supplied no arguments, the module is loaded normally, and the node classes
  710. are given the proper inheritence (from C<YAPE::Regex::Element>).  If you supply
  711. a module (or list of modules), C<import> will automatically include them (if
  712. needed) and set up I<their> node classes with the proper inheritence -- that is,
  713. it will append C<YAPE::Regex> to C<@MyExt::Mod::ISA>, and C<YAPE::Regex::xxx>
  714. to each node class's C<@ISA> (where C<xxx> is the name of the specific node
  715. class).
  716.  
  717.   package MyExt::Mod;
  718.   use YAPE::Regex 'MyExt::Mod';
  719.   
  720.   # does the work of:
  721.   # @MyExt::Mod::ISA = 'YAPE::Regex'
  722.   # @MyExt::Mod::text::ISA = 'YAPE::Regex::text'
  723.   # ...
  724.  
  725. =item * C<my $p = YAPE::Regex-E<gt>new($REx);>
  726.  
  727. Creates a C<YAPE::Regex> object, using the contents of C<$REx> as a regular
  728. expression.  The C<new> method will I<attempt> to convert C<$REx> to a compiled
  729. regex (using C<qr//>) if C<$REx> isn't already one.  If there is an error in
  730. the regex, this will fail, but the parser will pretend it was ok.  It will then
  731. report the bad token when it gets to it, in the course of parsing.
  732.  
  733. =item * C<my $text = $p-E<gt>chunk($len);>
  734.  
  735. Returns the next C<$len> characters in the input string; C<$len> defaults to
  736. 30 characters.  This is useful for figuring out why a parsing error occurs.
  737.  
  738. =item * C<my $done = $p-E<gt>done;>
  739.  
  740. Returns true if the parser is done with the input string, and false otherwise.
  741.  
  742. =item * C<my $errstr = $p-E<gt>error;>
  743.  
  744. Returns the parser error message.
  745.  
  746. =item * C<my $backref = $p-E<gt>extract;>
  747.  
  748. Returns a code reference that returns the next back-reference in the regex.
  749. For more information on enhancements in upcoming versions of this module, check
  750. L<Extracting Sections>.
  751.  
  752. =item * C<my $node = $p-E<gt>display(...);>
  753.  
  754. Returns a string representation of the entire content.  It calls the C<parse>
  755. method in case there is more data that has not yet been parsed.  This calls the
  756. C<fullstring> method on the root nodes.  Check the C<YAPE::Regex::Element> docs
  757. on the arguments to C<fullstring>.
  758.  
  759. =item * C<my $node = $p-E<gt>next;>
  760.  
  761. Returns the next token, or C<undef> if there is no valid token.  There will be
  762. an error message (accessible with the C<error> method) if there was a problem in
  763. the parsing.
  764.  
  765. =item * C<my $node = $p-E<gt>parse;>
  766.  
  767. Calls C<next> until all the data has been parsed.
  768.  
  769. =item * C<my $node = $p-E<gt>root;>
  770.  
  771. Returns the root node of the tree structure.
  772.  
  773. =item * C<my $state = $p-E<gt>state;>
  774.  
  775. Returns the current state of the parser.  It is one of the following values:
  776. C<alt>, C<anchor>, C<any>, C<backref>, C<capture(N)>, C<Cchar>, C<class>, C<close>,
  777. C<code>, C<comment>, C<cond(TYPE)>, C<ctrl>, C<cut>, C<done>, C<error>, C<flags>,
  778. C<group>, C<hex>, C<later>, C<lookahead(neg|pos)>, C<lookbehind(neg|pos)>,
  779. C<macro>, C<named>, C<oct>, C<slash>, C<text>, and C<utf8hex>.
  780.  
  781. For C<capture(N)>, I<N> will be the number the captured pattern represents.
  782.  
  783. For C<cond(TYPE)>, I<TYPE> will either be a number representing the
  784. back-reference that the conditional depends on, or the string C<assert>.
  785.  
  786. For C<lookahead> and C<lookbehind>, one of C<neg> and C<pos> will be there,
  787. depending on the type of assertion.
  788.  
  789. =item * C<my $node = $p-E<gt>top;>
  790.  
  791. Synonymous to C<root>.
  792.  
  793. =back
  794.  
  795. =head2 Extracting Sections
  796.  
  797. While extraction of nodes is the goal of the C<YAPE> modules, the author is at
  798. a loss for words as to what needs to be extracted from a regex.  At the current
  799. time, all the C<extract> method does is allow you access to the regex's set of
  800. back-references:
  801.  
  802.   my $extor = $parser->extract;
  803.   while (my $backref = $extor->()) {
  804.     # ...
  805.   }
  806.  
  807. C<japhy> is very open to suggestions as to the approach to node extraction (in
  808. how the API should look, in addition to what should be proffered).  Preliminary
  809. ideas include extraction keywords like the output of B<-Dr> (or the C<re>
  810. module's C<debug> option).
  811.  
  812. =head1 EXTENSIONS
  813.  
  814. =over 4
  815.  
  816. =item * C<YAPE::Regex::Explain> 3.00
  817.  
  818. Presents an explanation of a regular expression, node by node.
  819.  
  820. =item * C<YAPE::Regex::Reverse> (Not released)
  821.  
  822. Reverses the nodes of a regular expression.
  823.  
  824. =back
  825.  
  826. =head1 TO DO
  827.  
  828. This is a listing of things to add to future versions of this module.
  829.  
  830. =head2 API
  831.  
  832. =over 4
  833.  
  834. =item * Create a robust C<extract> method
  835.  
  836. Open to suggestions.
  837.  
  838. =back
  839.  
  840. =head1 BUGS
  841.  
  842. Following is a list of known or reported bugs.
  843.  
  844. =head2 Pending
  845.  
  846. =over 4
  847.  
  848. =item * C<use charnames ':full'>
  849.  
  850. To understand C<\N{...}> properly, you must be using 5.6.0 or higher.  However,
  851. the parser only knows how to resolve full names (those made using C<use charnames
  852. ':full'>).  There might be an option in the future to specify a class name.
  853.  
  854. =back
  855.  
  856. =head1 SUPPORT
  857.  
  858. Visit C<YAPE>'s web site at F<http://www.pobox.com/~japhy/YAPE/>.
  859.  
  860. =head1 SEE ALSO
  861.  
  862. The C<YAPE::Regex::Element> documentation, for information on the node classes.
  863. Also, C<Text::Balanced>, Damian Conway's excellent module, used for the matching
  864. of C<(?{ ... })> and C<(??{ ... })> blocks.
  865.  
  866. =head1 AUTHOR
  867.  
  868.   Jeff "japhy" Pinyan
  869.   CPAN ID: PINYAN
  870.   japhy@pobox.com
  871.   http://www.pobox.com/~japhy/
  872.  
  873. =cut
  874.